perm filename MOVER.F4[XX,LCS]3 blob
sn#193578 filedate 1975-12-24 generic text, type T, neo UTF8
00100 C****** MOVER, MVBEAM, MVBX, RTLINE, EXTEN, CLEFS
00200 SUBROUTINE MOVER
00300 IMPLICIT INTEGER(A-Q,S-Z)
00400 DIMENSION R(2,200),IR(2,200),NP(500)
00500 REAL POS,EXTEN,PRCNT,ACCX
00600 COMMON/FRMT/F78F(1),FA1(1),FA5(1),ASK/STF/RSTFAC(-3/4),RSTJ2
00700 COMMON/XRN/RN(4000) /KJY/ KY,JY
00800 COMMON R2,JA,CENTR,J2,RJQ(18),RX6,JR,L,RDIS,VY,JQ(17)
00900 COMMON/POSI/STFF(-3/4),JJ2,POS/PTR/PWDS(250),ITEM,LL,I,IX
01000 COMMON/ALF/INP(46),ACCX,ML,RRT,RZRO,RCNT,RJSZ,ROV,RSPC,KN,RA,RB,
01100 1 JLDGR,LDGR,JX,RW,RX,RY,RZ,JJ,RD,RQ,RE,RZZ,RN3,RN6,RV,RQ6
01200 EQUIVALENCE (R5,RJQ(3)),(R6,RJQ(4)),(R7,RJQ(5)),(R4,RJQ(2))
01300 1,(R3,RJQ(1)),(R8,RJQ(6)),(R9,RJQ(7)),(R11,RJQ(9))
01400 1,(IR,R,RN(3501)),(NP,RN(3000))
01500 DATA F78F/'(78F)'/,FA1/'(A1 )'/,FA5/'(A5 )'/,RSP/.5/,RI/4.5/
01600
01700 JJ2=-1
01800 J2=0
01900 ASK=-1
02000 C 99=BACKUP
02100 6 CALL VLINE(R2,R4,R5,R6)
02200 IF(R2.GE.99)RETURN
02300 IF(INP(1).EQ.'J')GO TO 12
02400 TYPE 5
02500 ACCEPT F78F,R7,R8,R9,R11
02600 RDIS=0
02700 REREAD FA1,L
02800 C FOR LPEN TYPE 'L'. BUT 4TH # MUST APPEAR WHEN NEEDED.
02900
03000 167 IF(R7.GE.99)GO TO 6
03100 IF(R2.GT.4)R7=R2
03200 IF(R7.NE.R2)TYPE 1200,R7
03300 1201 IF(L.NE.'L')GO TO 66
03400 DO 67 K=1,2
03500 R8=RY
03600 CALL LPEN(R7,RY,RX)
03700 67 IF(R7.GE.99)GO TO 6
03800 R9=RY
03900 CC66 JJ2=1
04000 66 NST=1
04100 C FOR START OF LOOP (1 UNLESS USING COPYIT)
04200 IF(INP(1).NE.'C')GO TO 68
04300 NST=ITEM+1
04400 CALL COPYIT
04500 68 IF(R11.NE.0)CALL UPDN(NST)
04600 JJ=0
04700 IF(R4.NE.R8.OR.R5.NE.R9)JJ=-1
04800 JY=0
04900 C JY IS CHANGED IN GETPTS
05000 IF(JJ)CALL GETPTS(NST)
05100 IF(R2.NE.R7)CALL STFCH
05200 IF(JY.EQ.0)RETURN
05300 CALL MOVIT
05400 RETURN
05500 12 IF(R4.EQ.0)R4=.001
05600 IF(R5.EQ.0)R5=200
05700 RCNT=0
05800 RRT=R5
05900 RZRO=R4
06000 RJSZ=RI
06100 CALL GETPTS(1)
06200 IF(JY.EQ.0)RETURN
06300 ROV=RRT
06400 PRCNT=1.
06500 R7=R2
06600 R6=0
06700 R11=0
06800 19 IF(RCNT.GT.9)GO TO 101
06900 RJSZ=RJSZ-.06
07000 RP=PRCNT
07100 RCNT=RCNT+1
07200 C TEMPORARY COUNTER
07300 TYPE F78F,RCNT
07400
07500 DO 11 KN=-3,4
07600 RSPC=0
07700 R8=KN
07800 N=0
07900
08000 DO 2 K=1,KY
08100 L=NP(K)
08200 RL=RN(L)
08300 RA=RN(L+1)
08400 RB=RN(L+3)
08500 IF(RN(L+2).EQ.R8)GO TO 77
08600 C THIS STAFF?
08700 IF(RA.NE.4)GO TO 2
08800 C SKIPS HOMED NOTES (IN CHORDS)
08900 CC77 IF(RA.EQ.1)GO TO 10
09000 CC27 IF(RA.LE.4)GO TO 177
09100 77 IF(RA.LT.3)GO TO 10
09200 IF(RA.EQ.4)GO TO 444
09300 IF(RA.EQ.3)GO TO 333
09400 C LOOKS AT NOTES,RESTS,CLEFS,BAR LINES,KSIGS,METERS.
09500 IF(RA.LT.17)GO TO 2
09600 GO TO 10
09700 333 IF(RL.LT.3)GO TO 10
09800 C <3 MEANS NOTHING IN P5
09900 IF(RN(L+5).GT.3)GO TO 2
10000 C NOT A REAL CLEF IF >3
10100 GO TO 10
10200 444 IF(RL.GT.2)GO TO 2
10300 C SHOULD CHECK ON BAR LINES NO MATTER WHICH STAFF
10400 10 N=N+1
10500 R(1,N)=RB
10600 IR(2,N)=L
10700 IF(N.EQ.200)GO TO 28
10800 C ONLY TREATS 200 ITEMS AT A TIME.
10900 2 CONTINUE
11000
11100 IF(N.EQ.0)GO TO 11
11200 28 DO 23 K=1,N
11300 23 IF(RN(IR(2,K)+1).NE.4)GO TO 24
11400 C SKIPS IF ONLY BAR LINES ON THIS STAFF
11500 GO TO 11
11600 24 RSTJ2=RSTFAC(KN)*PRCNT
11700 CALL SORT2(R,N)
11800
11900 C JUMP IF LAST IS A BAR LINE.
12000 K=0
12100 JLDGR=0
12200 JX=0
12300 22 K=K+1
12400 122 L=IR(2,K)
12500 RA=RN(L+1)
12600 RB=0
12700 RX=RN(L+5)
12800 C RX=PARAM 5
12900 RX6=RN(L+6)
13000 RY=1
13100 RW=AMOD(RN(L+4),100.)
13200 IF(RA.GT.1)GO TO 4
13300 RZ=RN(L+7)
13400 IF(LDGR.NE.JLDGR)JLDGR=0
13500 LDGR=0
13600 JK=K
13700 DO 32 JJ=JK+1,N+1
13800 K=JJ
13900 32 IF(R(1,JJ)-R(1,JJ-1).GT.RSP)GO TO 35
14000 C FOUND HOW MANY MEMBERS TO CHORD.
14100 35 RB=0
14200 K=K-1
14300 RQ=0
14400 RD=0
14500 125 IF(AMOD(RN(L+4),200.).GT.60.)RY=.6
14600 DO 37 JJ=JK,K-1
14700 IF(RD.NE.0)GO TO 38
14800 C FINDS ONLY HIGH OR! LOW LED. LINE.
14900 JR=IR(2,JJ)
15000 RW=AMOD(RN(JR+4),100.)
15100 IF(RW.GT.12)GO TO 277
15200 IF(RW.GE.2)GO TO 38
15300 277 LDGR=-1
15400 IF(RW.GT.11)LDGR=1
15500 IF(JLDGR.EQ.LDGR)GO TO 36
15600 JLDGR=LDGR
15700 C LDGR IS FOR LEDGER LINES.
15800 GO TO 38
15900 36 RD=1.5
16000 RQ=RD
16100 38 IF(RB.GT.2)GO TO 222
16200 C JUMP IF LARGE SPACE AFTER NOTE IS ALREADY SET UP.
16300 RZZ=RN(JR+7)
16400 RE=RN(JR+5)
16500 CC IF(RB.LT.2.AND.((AMOD(RZZ,10.).NE.0.AND.RE.LT.20).
16600 CC 1 OR.RZZ.GE.10))RB=1.5+EXTEN(RZZ)
16700 IF(RB.GE.2)GO TO 477
16800 IF(RZZ.GE.10)GO TO 377
16900 IF(RE.GE.20)GO TO 477
17000 IF(AMOD(RZZ,10.).EQ.0)GO TO 477
17100 377 RB=1.5+EXTEN(RZZ)
17200 C SPACE FOR DOT OR TAIL(IF STEM UP)
17300 477 IF(ABS(RN(JR+6)).EQ.10)RB=RB+2
17400 C FOR CHORD TONES ON RIGHT OF STEM UP.
17500 C LOOKS THROUGH ALL NOTES OF A CHORD.
17600 222 IF(AMOD(RE,10.).EQ.0)GO TO 37
17700 C JUMP IF NO ACCIS.
17800 425 RD=2*RY+EXTEN(RE)
17900 IF(RQ.GT.RD)RD=RQ
18000 RQ=RD
18100 C FUNCT. EXTEN=AMOD(X,1.)*10.
18200 37 CONTINUE
18300 IF(RY.NE.1)RB=RB-.5*RJSZ
18400 C MINI NOTES NEED LESS SPACE
18500 ACCX=0
18600 RC=0
18700 RW=R(1,JX+1)
18800 DO 132 JJ=JX+1,N
18900 IF(RW.NE.R(1,JJ))GO TO 25
19000 KX=IR(2,JJ)
19100 C GET POINTER
19200 IF(RN(KX+1).NE.1)GO TO 25
19300 C ONLY CHECK ON NOTES (THIS IS FOR CHRD NOTES WITH ACCIS)
19350 IF(ABS(RN(KX+6)).GE.20)RC=2.6
19400 RE=AMOD(RN(KX+5),10.0)
19500 C FIND AN ACCI
19600 IF(RE.EQ.0)GO TO 132
19700 IF(RE.GE.1)RC=RC+2
19800 C FOUND AN ACCI
19900 RC=AMOD(RE,1.0)*10.0+RC
20000 C ADD ANY EXTENSION TO THE LEFT
20100 IF(RC.GT.ACCX)ACCX=RC
20200 RC=0
20250 IF(ACCX.GT.RD)RD=ACCX
20300 132 CONTINUE
20400 25 IF(JX.GT.0)R(2,JX)=R(2,JX)+RD*RSTJ2
20500 GO TO 17
20600 4 IF(RA.NE.3)GO TO 29
20700 RB=3
20800 IF(RX.GT.100)RB=1.5
20900 C CHECK ON SIZE NEEDED FOR CLEFS
21000 29 IF(RA.NE.4)GO TO 26
21100 RB=-RJSZ/2
21200 RD=.9
21300 GO TO 25
21400 26 IF(RA.NE.18)GO TO 30
21500 IF(RX6.GT.9)GO TO 31
21600 IF(RX.GT.9)GO TO 31
21700 C CHECKS FOR 2-DIGIT METERS
21800 RB=-1
21900 RD=1
22000 GO TO 25
22100 31 RB=2
22200 RD=3
22300 GO TO 25
22400 30 IF(RA.NE.17)GO TO 17
22500 RB=2*(ABS(RX)-1)-2
22600 C SPACES FOR CORRECT NUM OF ACCIS. RX=NUM OF ACCIS.
22700 RD=2
22800 GO TO 25
22820 C ↑↑↑↑↑ TO RESET AFTER CHORD NOTES 12/75
22900 17 RC=(RB+RJSZ)*RSTJ2
23000 C RJSZ=DEFAULT SIZE
23100 JX=K
23200 R(2,JX)=RC
23300 CC??????? R(1,JX)=R(1,K)
23400 3 IF(K.LT.N)GO TO 22
23500 RA=R(1,1)
23600 RB=R(2,1)
23700
23800 DO 13 KX=2,JX
23900 RE=R(1,KX)
24000 C POS. BEFORE SHIFTING
24100 IF(ABS(RE-RA).GT..5)GO TO 14
24200 IF(R(2,KX).GT.RB)GO TO 16
24300 C SKIPS DOUBLE STOPS AND VERY CLOSE ITEMS
24400 GO TO 13
24500 C JUMP WHEN SPACE TO ADD IS SMALLER THAN WHAT'S ALREADY THERE
24600 14 RD=RA+RB-RE
24700 IF(RD.LE.0)GO TO 16
24800 C THERE'S ENOUGH ROOM
24900 ROV=ROV+RD
25000 140 R4=RE+RSPC-.001
25100 R5=10000
25200 R8=RD
25300 R9=0
25400 C GO EXPAND IT
25500 IF(R(2,KX).EQ.0)GO TO 15
25600 CALL MOVIT
25700 IF(R2.LE.4)GO TO 15
25800 R5=R4
25900 R4=RA+.001+RSPC
26000 R8=R4
26100 R9=R5+RD-.001
26200 C FOR ITEMS ON OTHER LINES.
26300 CALL MOVIT
26400 15 RSPC=RSPC+RD
26500 C RSPC SAVES TOTAL SPACE ADDED
26600 16 RB=R(2,KX)
26700 13 RA=RE
26800 11 CONTINUE
26900 110 IF(ROV.LE.RRT+.01)RETURN
27000 IF(RJSZ.GT.4)RJSZ=4
27100 PRCNT=(ROV-RZRO)/(RRT-RZRO)
27200 IF(PRCNT.NE.RP)GO TO 19
27300 C GO BACK AND EXPAND SOME MORE
27400 101 R4=RZRO
27500 R5=ROV
27600 R8=RZRO
27700 R9=RRT-.001
27800 C JUSTIFYING SPACE DIMINISHES EACH TIME AROUND.
27900 CALL MOVIT
28000 C RVX SHOULD BE FARTHEST POINT TO RIGHT.
28100 1200 FORMAT(' MOVED TO STAFF ',F4.0/)
28200 CALL HYDPOG(3)
28300 5 FORMAT(' TYPE NEW STAFF #, POS1, POS2, UP-DOWN # '$)
28400 END